home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / serror.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  9.0 KB  |  229 lines
  1. ;;;   -*- Mode:Lisp; Package:SERROR; Base:10; Syntax:COMMON-LISP -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;                                                                    ;;;;;
  4. ;;;     Copyright (c) 1985,86 by William Schelter,University of Texas  ;;;;;
  5. ;;;     All rights reserved                                            ;;;;;
  6. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  7. (require "SLOOP")
  8. (in-package "SERROR" :use '("SLOOP" "LISP"))
  9. (export '(def-error-type cond-error cond-any-error condition-case
  10.        error-name error-string error-continue-string error-format-args
  11.        ) "SERROR")
  12. (provide "SERROR")
  13.  
  14. (eval-when (compile)
  15.        (proclaim '(optimize (safety 2) (speed 2) (space 2))))
  16.  
  17. ;;do (require "SERROR")
  18. ;;(use-package "SERROR")
  19.  
  20. ;;This file contains two error catching facilities.  One based on
  21. ;;catch and throw, and the other which may involve a closure.  The
  22. ;;latter can be more costly for frequently executed forms, but has
  23. ;;the advantage that errors which match none of the conditions
  24. ;;will go into the regular error handler at the point in the stack where
  25. ;;the error occurred.
  26.  
  27. ;;First we set up an error catching for a common lisp
  28. ;;whose primitive error handler is called si:universal-error-handler (eg kcl).
  29. ;;Namely if *catch-error* is not nil then that means
  30. ;;there is a (catch ':any-error somewhere up the stack.
  31. ;;it is thrown to, along with the condition.  
  32. ;;At the that point if the condition matches that of 
  33. ;;the catch, it stops there,
  34. ;;otherwise if *catch-error* is still not nil repeat
  35. ;;Sample interface
  36.  
  37. ;(defun te (n m)
  38. ;  (cond-error (er) (hairy-arithmetic  m n)
  39. ;     ((and (= 0 n) (= 0 m))(format t "Hairy arithmetic doesn't like m=0=n") 58)
  40. ;     ((eql (error-condition-name er) :wrong-type-args)(format t "Bonus for wrong args") 50)
  41. ;     ((symbolp n)(and (numberp (symbol-value n))(format t "Had to eval n") (te m (symbol-value n)))))
  42.  
  43.  
  44.  
  45. ;;if none of the cond clauses hold, then we signal a regular error using
  46. ;;the system error handler , unless there are more *catch-error*'s up
  47. ;;the stack.  Major defect: If none of the conditions hold, we will have
  48. ;;to signal our real error up at the topmost *catch-error* so losing the possibility
  49. ;;of proceeding. The alternative is to some how get the tests down to where
  50. ;;we want them, but that seems to mean consing a closure, and keeping a
  51. ;;stack of them.  This is getting a little fancy.  
  52. ;;don't know how to get back (and anyway we have unwound by throwing).
  53. ;;Major advantages: If there is no error, no closures are consed, and
  54. ;;should be reasonably fast.
  55.  
  56.  
  57.  
  58. ;;****** Very system dependent.  Redefine main error handler ******
  59. (eval-when (load compile eval)
  60. #-kcl
  61. (defun si::universal-error-handler (&rest args)
  62.   (format t "Calling orignal error handler ~a" args))
  63.  
  64. (defvar *error-handler-function* 'si::universal-error-handler)
  65. (or (get   *error-handler-function* :old-definition)
  66.    (setf (get *error-handler-function* :old-definition)
  67.      (symbol-function *error-handler-function*)))
  68. )
  69.  
  70. (defstruct (error-condition :named (:conc-name error-))
  71.   name
  72.   string          ;the format string given to error.
  73.   function        ;occurs inside here
  74.   continue-string
  75.   format-args
  76.   error-handler-args)
  77.  
  78. (defparameter *catch-error* nil "If t errors will throw to :any-error tag")
  79. (defparameter *disable-catch-error* nil "If t only regular error handler will be used")
  80. (defparameter *catch-error-stack* (make-array 30 :fill-pointer 0) "If t only regular error handler will be used")
  81. (defvar *show-all-debug-info* nil "Set to t if not
  82.  running interactively")
  83.  
  84. ;;principal interfaces
  85.  
  86. (defmacro cond-error (variables body-form &body clauses)
  87.   "If a condition is signalled during evaluation of body-form, The first
  88. of VARIABLES is bound to the condition, and the clauses are evaluated
  89. like cond clauses. Note if the conditions involve lexical variables other than
  90. VARIABLES, there will be a new lexical closure cons'd each time through this!!
  91.  eg:
  92.  (cond-error (er) (1+ u)
  93.   ((null u) (princ er) (princ \"null arg to u\"))
  94.   ((symbolp u) (princ \"symbol arg\"))
  95.   (t 0))"
  96.  
  97.   (or variables (setf variables '(ignore)))
  98.   (let ((catch-tag (gensym "CATCH-TAG")))
  99.   (let ((bod `((catch ',catch-tag 
  100.            (return-from cond-error-continue
  101.                 (unwind-protect
  102.                 (progn
  103.                   (vector-push-extend
  104.                    #'(lambda ,variables ,(car variables)
  105.                        (if (or ,@ (mapcar 'car clauses)) ',catch-tag))
  106.                    *catch-error-stack*)
  107.                   ,body-form)
  108.                   (incf (the fixnum (fill-pointer *catch-error-stack*))
  109.                     -1))))
  110.          (cond ,@ clauses
  111.            (t (format t "should not get here") )))))
  112.   (cond (variables
  113.      (setf bod 
  114.           ` (multiple-value-bind
  115.         ,variables ,@ bod)))
  116.      (t (setf bod (cons 'progn bod))))
  117.   `(block cond-error-continue ,bod))))
  118.  
  119. (defmacro cond-any-error (variables body-form &body clauses)
  120.   "If a condition is signalled during evaluation of body-form, The first
  121. of VARIABLES is bound to the condition, and the clauses are evaluated
  122. like cond clauses, If the cond falls off the end, then the error is
  123. signaled at this point in the stack.  For the moment the rest of the VARIABLES are ignored.
  124.  eg:
  125.  (cond-error (er) (1+ u)
  126.   ((null u) (princ er) (princ \"null arg to u\"))
  127.   ((symbolp u) (princ \"symbol arg\"))
  128.   (t 0))"
  129.  
  130.   (let ((bod `(
  131.            (let ((*catch-error* t))
  132.          (catch ':any-error
  133.            (return-from cond-error-continue ,body-form)))
  134.            (cond ,@ clauses
  135.              (t (inf-signal ,@ variables))))))
  136.     (cond (variables
  137.        (setf bod 
  138.          ` (multiple-value-bind
  139.             ,variables ,@ bod)))
  140.       (t (setf bod (cons 'progn bod))))
  141.     `(block cond-error-continue ,bod)))
  142.  
  143.  
  144.  
  145. (defun #. (if (boundp '*error-handler-function*)*error-handler-function* 'joe)
  146.   (&rest error-handler-args)
  147.   (when *show-all-debug-info*
  148.        (si::simple-backtrace)(si::backtrace) (si::break-vs))
  149.   (let ((err (make-error-condition
  150.                  :name (car error-handler-args)
  151.                  :string (fifth error-handler-args)
  152.                  :function (third error-handler-args)
  153.                  :continue-string (fourth error-handler-args)
  154.                  :format-args
  155.                  (copy-list (nthcdr 5 error-handler-args))
  156.                  :error-handler-args (copy-list error-handler-args))))
  157.     (cond (*catch-error* (throw :any-error err))
  158.       ((let (flag) (do ((i 0 (the fixnum (1+ i)))
  159.                 (end (the fixnum(fill-pointer (the array
  160.                             *catch-error-stack*)))))
  161.                ((>= i end))
  162.                (declare (fixnum i end))
  163.                (cond ((setq flag
  164.                     (funcall (aref *catch-error-stack* i)
  165.                               err))
  166.                   (throw flag err))))))
  167.       (t    (apply (get *error-handler-function* :old-definition)
  168.                error-handler-args)))))
  169.  
  170. (defun inf-signal (&rest error-handler-args)
  171.  (apply *error-handler-function*
  172.                      (error-error-handler-args (car error-handler-args ))))
  173.  
  174. #|Sample call
  175. (defun te (n)
  176.   (cond-error (er) (progn (1+ n))
  177.      ((null n) (print n) (print er) n)
  178.      ((symbolp n) (print n))))
  179. |#
  180.  
  181. (defmacro def-error-type (name (er) &body body)
  182.   (let ((fname (intern (format nil "~a-tester" name))))
  183.   `(eval-when (compile eval load)
  184.       (defun ,fname (,er) ,@ body)
  185.       (deftype ,name ()`(and error-condition (satisfies ,',fname))))))
  186. (def-error-type wta (er) (eql (error-name er) :wrong-type-arg))
  187.  
  188. #|
  189. (def-error-type hi-error (er) (eql (error-string er) "hi"))
  190. ;this matches error signaled by (error "hi") or (cerror x "hi" ..)
  191. ;can use the above so that the user can put
  192. (cond-error (er ) (hairy-stuff)
  193.   ((typep er 'wta) ...)
  194.   ((typep er '(or hi-error joe)) ...)
  195. (defun te2 (n)
  196.   (sloop for i below n with x = 0 declare (fixnum x)
  197.      do (cond-any-error (er) (setq x i)
  198.             (t (print "hi")))))
  199. |#
  200. ;;In kcl cond-any-error is over 10 times as fast as cond-error, for the above.
  201. ;;Note since t a clause we could have optimized to cond-any-error!!
  202. ;;cond-error takes 1/1000 of second on sun 2
  203. ;;cond-any-error takes 1/10000 of second. (assuming no error!).
  204.  
  205.  
  206. (def-error-type subscript-out-of-bounds (er)
  207.   #+ti (member 'si::subscript-out-of-bounds (funcall er :condition-names))
  208.   #+gcl(equal (error-string er) "The first index, ~S, to the array~%~S is too large.")) ;should collect all here
  209. (def-error-type ERROR (er) (eql (error-name er) :error))
  210. (def-error-type WRONG-TYPE-ARGUMENT (er)  (eql (error-name er) :WRONG-TYPE-ARGUMENT))
  211. (def-error-type TOO-FEW-ARGUMENTS (er)  (eql (error-name er) :TOO-FEW-ARGUMENTS))
  212. (def-error-type TOO-MANY-ARGUMENTS (er)  (eql (error-name er) :TOO-MANY-ARGUMENTS))
  213. (def-error-type UNEXPECTED-KEYWORD (er)  (eql (error-name er) :UNEXPECTED-KEYWORD))
  214. (def-error-type INVALID-FORM (er)  (eql (error-name er) :INVALID-FORM))
  215. (def-error-type UNBOUND-VARIABLE (er)  (eql (error-name er) :UNBOUND-VARIABLE))
  216. (def-error-type INVALID-VARIABLE (er)  (eql (error-name er) :INVALID-VARIABLE))
  217. (def-error-type UNDEFINED-FUNCTION (er)  (eql (error-name er) :UNDEFINED-FUNCTION))
  218. (def-error-type INVALID-FUNCTION (er)   (eql (error-name er) :INVALID-FUNCTION))
  219.  
  220. (defmacro condition-case (vars body-form &rest cases)
  221.   (let ((er (car vars)))
  222.   `(cond-error (,er) ,body-form
  223.            ,@ (sloop for v in cases
  224.              when (listp (car v))
  225.              collecting `((typep ,er '(or ,@ (car v))),@ (cdr v))
  226.              else
  227.              collecting `((typep ,er ',(car v)),@ (cdr v))))))
  228.  
  229.